home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / you-075a.lha / you-075a / copy.c < prev    next >
C/C++ Source or Header  |  1992-11-25  |  34KB  |  1,250 lines
  1. /* ******************************************************************** */
  2. /*  copy.c        copyright (c) university of bath 1992            */
  3. /*                                                                      */
  4. /* creation of modules                            */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: copy.c,v 1.36 1992/11/25 16:48:42 djb Exp $
  9.  *
  10.  * $Log: copy.c,v $
  11.  * Revision 1.36  1992/11/25  16:48:42  djb
  12.  * changed args to d-gc's gc_malloc - added gc_enabled
  13.  *
  14.  * Revision 1.35  1992/10/27  15:27:26  pab
  15.  * real changes
  16.  *
  17.  * Revision 1.31  1992/06/16  19:36:24  pab
  18.  * weak wrapper code
  19.  *
  20.  * Revision 1.30  1992/06/14  16:43:45  pab
  21.  * incorporated branch from V1.26
  22.  *
  23.  * Revision 1.29  1992/05/29  12:18:03  pab
  24.  * changed headers
  25.  *
  26.  * Revision 1.28  1992/05/29  09:53:44  rjb
  27.  * ALIGN8 and a NULL -> 0
  28.  *
  29.  * Revision 1.27  1992/05/29  09:47:44  djb
  30.  * hooks for CGC mark+sweep (all #ifdef CGC)
  31.  *
  32.  * Revision 1.26  1992/04/30  19:41:21  pab
  33.  * fiddled with tracing
  34.  *
  35.  * Revision 1.25  1992/04/30  11:07:31  pab
  36.  * lost end-page bug. Lowered rounding
  37.  *
  38.  * Revision 1.24  1992/04/29  12:33:18  pab
  39.  * tracing code added
  40.  *
  41.  * Revision 1.23  1992/04/27  21:55:42  pab
  42.  * if it moves, round it
  43.  *
  44.  * Revision 1.22  1992/04/26  20:55:46  pab
  45.  * fixes for generic version, plus static vector type preliminary support,
  46.  * no-sockets fixes
  47.  *
  48.  * Revision 1.21  1992/03/13  18:06:51  pab
  49.  * SysV fixes (mainly relinquishing pages and synchonisation)
  50.  *
  51.  * Revision 1.20  1992/02/27  15:46:57  pab
  52.  * bytecode + error changes
  53.  *
  54.  * Revision 1.19  1992/02/13  13:49:58  pab
  55.  * *** empty log message ***
  56.  *
  57.  * Revision 1.17  1992/02/11  13:38:04  pab
  58.  * removed printing gc_enabled
  59.  *
  60.  * Revision 1.16  1992/02/10  12:11:41  pab
  61.  * fixed circular lists
  62.  * gc_enabaled now global
  63.  *
  64.  * revision 1.12  1991/04/02  21:25:30  kjp
  65.  * compiler tidying.
  66.  * copying garbage collector. Replaces allocate + garbage.c */
  67.  
  68. #include "defs.h"
  69. #include "structs.h"
  70. #include "funcalls.h"
  71. #include "global.h"
  72. #include "state.h"
  73. #include "copy.h"
  74. #include "weak.h"
  75.  
  76. #define N_SLOTS_IN_CLASS N_SLOTS_IN_STRUCT(struct class_structure)
  77. #define N_SLOTS_IN_THREAD N_SLOTS_IN_STRUCT(struct thread_structure)
  78.  
  79. #define OTHER_SPACE(x) 1-(x)
  80.  
  81. #define is_newspace(x) \
  82.   ((gcof(x)&1) ==wspace)
  83.  
  84. #define forwardof(x) \
  85.   (lval_classof(x))
  86.  
  87. #define set_forwarded(x, new) \
  88.   ( *(&gcof(x))|=0x2 , forwardof(x)=new)
  89.  
  90. #define is_forwarded(x) \
  91.   ((gcof(x))&0x2)
  92.   
  93. #define HEADERSIZE sizeof(Object_t)
  94. /* should not need to allocate any fixed objects yet... */
  95. #ifdef ALIGN8
  96. #define ROUNDTO 8
  97. #else
  98. #define ROUNDTO 4
  99. #endif
  100. #define ROUND_ADDR(x) ((((int)x)&(ROUNDTO-1))==0 ? (x) : (x)+(ROUNDTO-(((int)x)&(ROUNDTO-1))))
  101. #define is_fixed(x) 0
  102.  
  103. #ifndef NODEBUG
  104. #define TRACE_GC  /* writes allocation logging to a file */
  105. #endif
  106. #ifdef TRACE_GC
  107. #include <time.h>
  108.   FILE *trace_file;
  109.   int counters[256];
  110.   int total_moved;
  111. #endif
  112.  
  113. /* which space are we in */
  114. static int wspace;
  115. static char *free_ptr;
  116. static char *pg_end;
  117. int gc_paranoia=0;
  118. static int collect_count;
  119.  
  120. /* BSD + SYSV */
  121. static LispObject GC_thread;
  122.   
  123. /* SYSV only */
  124. SYSTEM_GLOBAL(SystemSemaphore,GC_sem);
  125. SYSTEM_GLOBAL(SystemSemaphore,Rig_sem);
  126. SYSTEM_GLOBAL(int,GC_state);
  127. static SYSTEM_GLOBAL(int,GC_register);      /* Who's arrived so far... */
  128. static SYSTEM_GLOBAL(int,GC_exit_register); /* Who's left... */
  129. static SYSTEM_GLOBAL(int,GC_turn);         /* whose go */
  130. static SYSTEM_GLOBAL(int,gc_enabled);         /* can we... */
  131. static SYSTEM_GLOBAL_ARRAY1(LispObject,GC_register_array,MAX_PROCESSORS);
  132. static LispObject GC_tame_continue;
  133. static SYSTEM_GLOBAL(PageList, old_pages);
  134. /* Valid only in non-gc time */
  135. static SYSTEM_GLOBAL(PageList, free_pages);
  136. static SYSTEM_GLOBAL(int,npages);
  137. static SYSTEM_GLOBAL(int,pagelim);
  138.  
  139. static SYSTEM_GLOBAL(LispObject, weak_list);
  140.  
  141. static PageList current_page;
  142. static PageList used_pages;
  143.  
  144. /* Called from inside copier */
  145. #define ALLOC_SPACE(new,type,ptr,size) \
  146.   {  \
  147.     new= (type) ptr;         \
  148.     ptr+=size;             \
  149.     if (ptr>=pg_end) \
  150.       {                \
  151.     GRAB_PAGE(NULL,ptr,pg_end);    \
  152.     new= (type) ptr;         \
  153.     ptr+=size;        \
  154.        }            \
  155.       }
  156.  
  157. #ifdef MACHINE_ANY
  158. #define GRAB_PAGE_INTERNAL(stacktop,ptr,top)         \
  159.    {                     \
  160.       ptr=free_pages->start;         \
  161.       top=free_pages->end;         \
  162.       current_page=free_pages;        \
  163.       free_pages=free_pages->next;         \
  164.       current_page->next=used_pages;         \
  165.       used_pages=current_page;              \
  166.       npages++;                    \
  167.       COPY_BUG(fprintf(stderr,"{Grab: %d}",    \
  168.                current_page->id));    \
  169.     }
  170.  
  171. #define GRAB_PAGE(x,y,z) GRAB_PAGE_INTERNAL(x,y,z)
  172.  
  173. #else
  174. #define GRAB_PAGE_INTERNAL(stacktop,ptr,top)         \
  175.    {                     \
  176.       ptr=ROUND_ADDR(S_G_V(free_pages)->start);         \
  177.       top=S_G_V(free_pages)->end;         \
  178.       current_page=S_G_V(free_pages);        \
  179.       S_G_V(free_pages)=S_G_V(free_pages)->next;         \
  180.       current_page->next=used_pages;         \
  181.       used_pages=current_page;              \
  182.       S_G_V(npages)++;                    \
  183.       COPY_BUG(fprintf(stderr,"{Grab(%d): %d}",    \
  184.                system_scheduler_number,        \
  185.                current_page->id));        \
  186.       COPY_BUG(memset(ptr,'x',top-ptr));        \
  187.     }
  188.  
  189. #define GRAB_PAGE(stacktop,ptr,top)         \
  190.   {                            \
  191.     system_open_semaphore(stacktop,&S_G_V(GC_sem));     \
  192.     GRAB_PAGE_INTERNAL(stacktop,ptr,top);        \
  193.     system_close_semaphore(&S_G_V(GC_sem));        \
  194.   }
  195.  
  196. #endif
  197.  
  198. #define MAYBE_GRAB_PAGE(res,stacktop,ptr,top)             \
  199. {                            \
  200.     system_open_semaphore(stacktop,&S_G_V(GC_sem));     \
  201.     if (S_G_V(npages)<S_G_V(pagelim))            \
  202.       {                            \
  203.         GRAB_PAGE_INTERNAL(stacktop,ptr,top);        \
  204.         res=1;                        \
  205.       }                            \
  206.     else                        \
  207.       res=0;                    \
  208.   /**/                        \
  209.     system_close_semaphore(&S_G_V(GC_sem)); \
  210.   }
  211.   
  212. #define PRINT_LISTS(stream)        \
  213. {            \
  214.     PageList xx;        \
  215.     fputs("Free: ",stream);    \
  216.     xx=S_G_V(free_pages);        \
  217.     while (xx!=NULL)        \
  218.       { fprintf(stream,"%d ",xx->id);        \
  219.     xx=xx->next;        \
  220.       }                \
  221.     fputs("\nUsed: ",stream);    \
  222.     xx=used_pages;        \
  223.     while (xx!=NULL)        \
  224.       { fprintf(stream,"%d ",xx->id);        \
  225.     xx=xx->next;        \
  226.       }        \
  227.     fputc('\n',stream);        \
  228.   }
  229.  
  230.  
  231. void init_allocator(int size)
  232. {
  233. #ifdef DGC
  234.   gc_init(size);
  235. #else
  236.   PageList *newpage;
  237.   char *space=system_malloc(2*size);
  238.   char *end=space+2*size;
  239.   int pg_count=0;
  240.  
  241.   COPY_BUG(memset(space,'T',2*size));
  242. #endif
  243. #ifndef MACHINE_ANY
  244.  
  245.   SYSTEM_INITIALISE_GLOBAL(SystemSemaphore,GC_sem,NULL);
  246.   system_allocate_semaphore(&S_G_V(GC_sem));
  247.   SYSTEM_INITIALISE_GLOBAL(SystemSemaphore,Rig_sem,NULL);
  248.   system_allocate_semaphore(&S_G_V(Rig_sem));
  249.   SYSTEM_INITIALISE_GLOBAL(int,GC_state,GC_DONE);
  250.   SYSTEM_INITIALISE_GLOBAL(int,GC_register,0);
  251.   SYSTEM_INITIALISE_GLOBAL(int,GC_exit_register,0);
  252.   SYSTEM_INITIALISE_GLOBAL(int,pagelim,0);
  253.   SYSTEM_INITIALISE_GLOBAL(PageList,free_pages,NULL);
  254.   SYSTEM_INITIALISE_GLOBAL(PageList,old_pages,NULL);
  255.   SYSTEM_INITIALISE_GLOBAL(int,npages,NULL);
  256.   SYSTEM_INITIALISE_GLOBAL(int,GC_turn,NULL);
  257.   SYSTEM_INITIALISE_GLOBAL_ARRAY1(LispObject,
  258.                   GC_register_array,MAX_PROCESSORS,NULL);
  259. #endif
  260.  
  261.   SYSTEM_INITIALISE_GLOBAL(int,gc_enabled,0);
  262.   SYSTEM_INITIALISE_GLOBAL(LispObject,weak_list,NULL);
  263. #ifndef DGC
  264.   newpage= &S_G_V(free_pages);  
  265.   while (space<end)
  266.     {    
  267.       *newpage=(PageList) space;
  268.       (*newpage)->status=PAGE_FREE;
  269.       (*newpage)->end= ((space+PAGE_SIZE) < end ? space+PAGE_SIZE : end);
  270.       (*newpage)->id=pg_count;
  271.       newpage= &((*newpage)->next);
  272.       space+=PAGE_SIZE;
  273.       pg_count++;
  274.     }
  275.   *newpage=NULL;
  276.   
  277.   printf("Initialised with: %x [%d pages]\n",size,pg_count);
  278.   COPY_BUG(PRINT_LISTS(stderr));
  279.   used_pages=NULL;
  280.   wspace=0;
  281.   S_G_V(pagelim)=pg_count/2;
  282.   S_G_V(npages)=0;
  283.   GRAB_PAGE(NULL,free_ptr,pg_end);
  284. #endif
  285. }
  286.  
  287.  
  288. void runtime_initialise_garbage_collector(LispObject *stacktop)
  289. {
  290.   (GC_tame_continue)=allocate_continue(stacktop);
  291.   GC_thread=nil;
  292.  
  293.   add_root(&GC_tame_continue);
  294.   add_root(&GC_thread);
  295. }
  296.  
  297. void initialise_garbage(LispObject *stacktop)
  298. {  /* Pretend we're a module */
  299.   LispObject garbage_collect(LispObject *);
  300.  
  301.   GC_thread = allocate_thread(stacktop,2048,1024,0);
  302.   (void) make_module_function(stacktop,"GC",garbage_collect,0);
  303. }
  304.  
  305. /* Called when a new process forks */
  306. #ifndef MACHINE_ANY
  307. void runtime_reset_allocator(LispObject *stacktop)
  308. {
  309.   COPY_BUG(fprintf(stderr,"Proc: %d starting\n",system_scheduler_number));
  310.  
  311.   used_pages=NULL;
  312.   GRAB_PAGE(NULL,free_ptr,pg_end);
  313.  
  314.   GC_thread = allocate_thread(stacktop,2048,1024,0);
  315.   add_root(&GC_thread);
  316.   (GC_tame_continue)=allocate_continue(stacktop);
  317.   add_root(&GC_tame_continue);
  318.   system_open_semaphore(stacktop,&S_G_V(Rig_sem));
  319.   RIG_GC_THREAD(stacktop);
  320.   system_close_semaphore(&S_G_V(Rig_sem));
  321.  
  322. }
  323. #endif
  324.  
  325. EUFUN_0(garbage_collect)
  326. {
  327.   void do_gc_sync(LispObject *);
  328.  
  329.   do_gc_sync(stacktop);
  330.   return nil;
  331.  
  332. }
  333. EUFUN_CLOSE
  334.  
  335. int current_space()
  336. {
  337.   return wspace;
  338. }
  339.  
  340. #ifndef MACHINE_ANY
  341. extern void rig_gc_thread(LispObject *stacktop)
  342. {
  343. #ifndef MACHINE_ANY
  344.   RIG_GC_THREAD(stacktop);
  345. #endif
  346. }
  347. #endif
  348.  
  349. /* c-roots */
  350. #define MAXROOTS 300
  351. int nroots=0;
  352.  
  353. LispObject *roots[MAXROOTS];
  354.  
  355. int add_root(LispObject *root)
  356. {    
  357.   int x=nroots;
  358.  
  359.   roots[nroots++]=root;
  360.   
  361.   return x;
  362. }
  363.  
  364. void copy_root(LispObject *x)
  365. {
  366.   LispObject copy_object(LispObject);
  367.   *x=copy_object(*x);
  368. }
  369.  
  370. void copy_on()
  371. {
  372.   S_G_V(gc_enabled)++;
  373.   COPY_BUG(fprintf(stderr,"{+%d}",S_G_V(gc_enabled)));
  374. }
  375.  
  376. void copy_off()
  377. {
  378.   S_G_V(gc_enabled)--;
  379.   COPY_BUG(fprintf(stderr,"{-%d}",S_G_V(gc_enabled)));
  380. }
  381.  
  382. /* These will have to more complicated eventually */
  383. void ON_collect()
  384. {
  385.   S_G_V(gc_enabled)++;
  386.   COPY_BUG(fprintf(stderr,"{+%d}",S_G_V(gc_enabled)));
  387. }
  388.  
  389. void OFF_collect()
  390. {
  391.   S_G_V(gc_enabled)--;
  392.   COPY_BUG(fprintf(stderr,"{-%d}",S_G_V(gc_enabled)));
  393. }
  394. /****************************************
  395.  * allocation 
  396.  ****************************************/
  397.  
  398. static int a_count;
  399. #define ALLOC_GAP 2048
  400. int alloc_gap=ALLOC_GAP;
  401.  
  402. #ifdef DGC
  403. LispObject *the_stacktop;
  404.  
  405. LispObject allocate_nbytes(LispObject *stacktop,int n,int type)
  406. {
  407.   LispObject object;
  408.  
  409.   the_stacktop = stacktop;
  410.   object=(LispObject)gc_malloc(n,S_G_V(gc_enabled));
  411.   lval_typeof(object)=type;
  412.   return(object);
  413. }
  414. #else
  415. LispObject allocate_nbytes(LispObject *stacktop,int n,int type)
  416. {
  417.   void do_gc_sync(LispObject *);
  418.   LispObject object;
  419.   char *new;
  420.   
  421.   COPY_BUG(if (n<HEADERSIZE) fprintf(stderr,"Object too small to hold header\n") );
  422.  
  423. #ifdef TRACE_GC
  424.   counters[type&255]++;
  425. #endif
  426.  
  427. #ifndef NODEBUG  
  428.   if (gc_paranoia)
  429.     fprintf(stdout,"{%x:%d}",type,n);
  430. #endif
  431.   n=ROUND_ADDR(n);
  432.   a_count+=n;
  433. #ifdef NODEBUG
  434.   if ( !(free_ptr+n<pg_end))
  435. #else
  436.   if ((gc_paranoia && a_count>alloc_gap && S_G_V(gc_enabled))
  437.       || !(free_ptr+n<pg_end))
  438. #endif    
  439.     {
  440.       int res;
  441.       MAYBE_GRAB_PAGE(res,stacktop,free_ptr,pg_end);
  442.       
  443.       if (!res)
  444.     {
  445.       a_count=0;
  446.       if (S_G_V(gc_enabled)<1)
  447.         { 
  448.           fprintf(stderr,"{Grabbed Page 'cos I couldn't GC[%d]}\n",S_G_V(gc_enabled));
  449.           GRAB_PAGE(stacktop,free_ptr,pg_end);
  450.         }
  451.       else
  452.         {
  453.           do_gc_sync(stacktop);
  454.         }
  455.     }
  456.     }
  457.   ALLOC_SPACE(object,LispObject,free_ptr,n);
  458.  
  459.   lval_typeof(object)=type;
  460.   gcof(object)=(short)wspace;
  461.   return(object);
  462. }
  463. #endif
  464.  
  465. #ifdef MACHINE_ANY
  466. void do_gc_sync(LispObject *stacktop)
  467. {
  468.   static void free_old_pages(void);
  469.   static void swap_spaces(LispObject *);    
  470.   static void free_weak_ptrs(void);
  471.   fprintf(stderr,"Collection %d initiated: %d used, %d bytes (%d%%) remaining\n",
  472.       collect_count,S_G_V(npages)*PAGE_SIZE,(S_G_V(pagelim)-S_G_V(npages))*PAGE_SIZE,0);
  473.   
  474.    S_G_V(old_pages)=NULL;
  475.    S_G_V(npages)=0;
  476.    S_G_V(weak_list)=NULL;
  477.    swap_spaces(stacktop);
  478.   
  479.    free_old_pgs();
  480.    free_weak_ptrs();
  481.  }
  482. #else /* ! MACHINE_ANY */
  483. void do_gc_sync(LispObject *stacktop)
  484. {
  485.   static void free_weak_ptrs(void);
  486.   static void free_old_pages(void);
  487.   int i;
  488.  
  489. #ifdef DGC
  490.   void tidy_stacks(LispObject *);
  491.   tidy_stacks(the_stacktop);
  492.  
  493.   stacktop = the_stacktop;
  494. #endif
  495.  
  496.   /* we must save state early */
  497.   save_state(stacktop,CURRENT_THREAD()->THREAD.state);
  498.   /* Wait for the last gc to finish */
  499.   while (  S_G_V(GC_state)!=GC_DONE
  500.      &&S_G_V(GC_state)!=GC_SINKING)
  501.     ;
  502.   /* register myself */
  503.   system_open_semaphore(stacktop,&S_G_V(GC_sem));
  504.   ++S_G_V(GC_register);
  505.   if (S_G_V(GC_register) == 1)
  506.     {                    /* First */
  507.       S_G_V(GC_state) = GC_SINKING;
  508.       fprintf(stderr,"GC sinking(%d) ---  ",S_G_V(gc_enabled));
  509.     }
  510.  
  511.   fprintf(stderr,"%d ",system_scheduler_number);
  512.   /* if last, set flag */
  513.   if (S_G_V(GC_register) == RUNNING_PROCESSORS())
  514.     { /* Last */
  515.       S_G_V(GC_state) = GC_REGISTERED;
  516.       fprintf(stderr,"\n ",system_scheduler_number); fflush(stdout);
  517.       fprintf(stderr,"Collection %d initiated: %d used, %d bytes (%d%%) remaining\n",
  518.           collect_count,S_G_V(npages)*PAGE_SIZE,(S_G_V(pagelim)-S_G_V(npages))*PAGE_SIZE,0);
  519.       S_G_V(GC_turn)=0;
  520.       S_G_V(npages)=0;
  521.       S_G_V(old_pages) = NULL;
  522.       S_G_V(weak_list)=NULL;
  523.     }        
  524.   
  525.   system_close_semaphore(&S_G_V(GC_sem));
  526.   
  527.  
  528.   SYSTEM_GLOBAL_ARRAY1_VALUE(GC_register_array,system_scheduler_number) 
  529.     = CURRENT_THREAD();
  530.   
  531.   /* boot any sleepers */
  532.  
  533.   system_kick_sleepers();
  534.  
  535.   /* wait until all get the idea */
  536.   while (S_G_V(GC_state)!=GC_REGISTERED)
  537.     ;
  538.   /* Save myself */
  539.  
  540.   /* we all copy --- in serial 'cos its easier that way */
  541.  
  542.   while(S_G_V(GC_turn)!=system_scheduler_number)
  543.     ;
  544.  
  545.   if (!set_continue(stacktop,(GC_tame_continue)))
  546.     {
  547.       LispObject temp = CURRENT_THREAD();
  548.       LispObject *newstack;
  549.  
  550.       COPY_BUG(fprintf(stderr," {Proc: %d leaping %x %x %x}\n",system_scheduler_number,
  551.                (GC_tame_continue)->CONTINUE.thread,GC_thread,temp));
  552.       newstack = load_thread(GC_thread);
  553.       call_continue(newstack,GC_thread->THREAD.state,temp);
  554.     }
  555.   
  556.   /* done: should signal this */
  557.  
  558.   S_G_V(GC_turn)++;
  559.   
  560.   if (system_scheduler_number==RUNNING_PROCESSORS()-1)
  561.     {    
  562. #ifndef DGC
  563.       free_old_pgs();
  564.       free_weak_ptrs();
  565. #endif
  566.       S_G_V(GC_state)=GC_MARKED;
  567.     }
  568.  
  569.   while(S_G_V(GC_state)!=GC_MARKED)
  570.       ;
  571.   /* Now we can go */
  572.  
  573.   system_open_semaphore(stacktop,&S_G_V(GC_sem));
  574.   --S_G_V(GC_register);
  575.   if (S_G_V(GC_register)==0)
  576.     S_G_V(GC_state)=GC_DONE;
  577.   system_close_semaphore(&S_G_V(GC_sem));
  578.  
  579.   
  580.   fprintf(stderr,"GC done\n");
  581.   
  582. }
  583.  
  584.  
  585. #ifdef DGC
  586. void gcollect()
  587. {
  588.   long time_now;
  589.  
  590.   time_now=time(NULL);
  591.   fprintf(stderr,"GC started %s\n",ctime(&time_now));
  592.  
  593.   do_gc_sync(NULL);
  594.  
  595.   time_now=time(NULL);
  596.   fprintf(stderr,"GC finished %s\n",ctime(&time_now));
  597. }
  598. #endif
  599.  
  600. void first_gc_mark_call(LispObject *stacktop)
  601. {
  602. #ifdef DGC
  603.   void real_gcollect();
  604. #else
  605.   void swap_spaces(LispObject *stacktop);
  606. #endif
  607.  
  608.   LispObject ret;
  609.  
  610.   COPY_BUG(printf("First invokation of GC mark: %x\n",stacktop); fflush(stdout));
  611.   stacktop=GC_thread->THREAD.gc_stack_base;
  612.  reset:
  613.  
  614.   ret = GC_thread->THREAD.state->CONTINUE.value;
  615.  
  616.   COPY_BUG(printf("Laying continue in GC mark: %x\n",stacktop); fflush(stdout));    
  617.   if (set_continue(stacktop,(GC_thread->THREAD.state)))
  618.     {    
  619.       goto reset;
  620.     }
  621.   STACK_TMP(ret);
  622.  
  623.   COPY_BUG(printf("Marking in GC mark\n"); fflush(stdout));
  624.  
  625. #ifdef DGC
  626.   real_gcollect();
  627. #else
  628.   swap_spaces(stacktop);
  629. #endif
  630.   UNSTACK_TMP(ret);
  631.   COPY_BUG(fprintf(stderr,"Jumping back: target: (%x %d) %x %d %d %d %d\n  gc_thread: (%x %d) %x %d %d\n",
  632.            ret,ret->THREAD.header.gc,
  633.            ret->THREAD.state, 
  634.            ret->THREAD.state->CONTINUE.header.gc,
  635.            ret->THREAD.state->CONTINUE.header.type,
  636.            ret->THREAD.state->CONTINUE.handler_stack->CONS.header.type,
  637.            ret->THREAD.state->CONTINUE.handler_stack->CONS.header.gc,
  638.            GC_thread,
  639.            GC_thread->THREAD.header.gc,
  640.            GC_thread->THREAD.state, 
  641.            GC_thread->THREAD.state->CONTINUE.header.gc,
  642.            GC_thread->THREAD.state->CONTINUE.header.type);
  643.        fflush(stdout));
  644.   /**save_state(stacktop,GC_thread);**/
  645.   (void) load_thread(ret); /* this returns the wrong value for our porpoises */
  646.   call_continue(NULL,(GC_tame_continue),nil);
  647. }
  648. #endif
  649.  
  650.  
  651.  
  652. /* Collection */
  653.  
  654. void swap_spaces(LispObject *stacktop)
  655. {
  656.   void copy_root(LispObject *);
  657.   void show_stack_space(void);
  658.   static void free_old_pgs(void);
  659.  
  660.   char *oldspace;
  661.   PageList pg,tmp,*ptr;
  662.   int i;
  663.  
  664. #ifdef TRACE_GC
  665.   {
  666.     long time_now;
  667.     char *str;
  668.     int k,j=0;
  669.     
  670.     if (trace_file==NULL)
  671.       {    
  672.       char *buf[20];
  673.       sprintf(buf,"/tmp/gc.%d",getpid());
  674.   
  675.       trace_file=fopen(buf,"w");
  676.       }
  677.  
  678.     time_now=time(NULL);
  679.     str=ctime(&time_now);
  680.     fprintf(trace_file,"GC %d started: %s\n",collect_count,str);
  681.     fprintf(trace_file,"Used: %d\n",S_G_V(npages)*PAGE_SIZE);
  682.  
  683.     for (k=0; k<255; k++)
  684.       {    
  685.     if (counters[k]!=0)
  686.       {
  687.         fprintf(trace_file,"%d: %6d ",k,counters[k]);
  688.         if ((++j)%6==0)
  689.           fputc('\n',trace_file);
  690.       }
  691.     counters[k]=0;
  692.       }    
  693.     total_moved=0;
  694.     fputc('\n',trace_file);
  695.     PRINT_LISTS(trace_file);
  696.     fflush(trace_file);
  697.   }
  698. #endif
  699.   
  700.   /* make sure that all is well */
  701.   save_state(stacktop,CURRENT_THREAD()->THREAD.state);
  702.   COPY_BUG(PRINT_LISTS(stderr));
  703.   
  704.   pg=current_page;
  705.   used_pages=NULL;
  706.   wspace=1-wspace;
  707.   /* begin the copy process */
  708.   GRAB_PAGE(stacktop,free_ptr,pg_end);
  709.  
  710.   for (i=0; i < nroots; i++)
  711.     copy_root(roots[i]);
  712.  
  713.   /* Free all oldspace */
  714.   /* Assumes that free_pages is unlocked */
  715.   while (pg!=NULL)
  716.     { /* insertion sort on the old pages */
  717.       tmp=pg->next;
  718.  
  719.       ptr=&S_G_V(old_pages);
  720.       if (*ptr!=NULL)
  721.     {
  722.       while ((*ptr)->next!=NULL
  723.          && (*ptr)->next->id < pg->id)
  724.         ptr=&(*ptr)->next;
  725.       
  726.       pg->next=(*ptr)->next;
  727.       (*ptr)->next=pg;
  728.     }
  729.       else 
  730.     {
  731.       *ptr=pg;
  732.       pg->next=NULL;
  733.     }
  734.       pg=tmp;
  735.     }
  736.  
  737.   fprintf(stderr,"Collection Completed: %d used, %d bytes (%d%%) remaining\n",
  738.       S_G_V(npages)*PAGE_SIZE,
  739.       (S_G_V(pagelim)-S_G_V(npages))*PAGE_SIZE,
  740.       ((S_G_V(pagelim)-S_G_V(npages))*100)/
  741.       S_G_V(pagelim));
  742.   show_stack_space();
  743.   collect_count++;
  744.   COPY_BUG(PRINT_LISTS(stderr));
  745.  
  746. #ifdef TRACE_GC
  747.   {
  748.     long time_now;
  749.     char *str;
  750.     int k,j;
  751.     time_now=time(NULL);
  752.     str=ctime(&time_now);
  753.     fprintf(trace_file,"Using: %d\n",S_G_V(npages)*PAGE_SIZE);
  754.     PRINT_LISTS(trace_file);
  755.     fprintf(trace_file,"Totals: %d\n",total_moved);    
  756.     for (k=0,j=0; k<255; k++)
  757.       {    
  758.     if (counters[k]!=0)
  759.       {
  760.         fprintf(trace_file,"%d: %6d ",k,counters[k]);
  761.         if ((++j)%6==0)
  762.           fputc('\n',trace_file);
  763.         counters[k]=0;
  764.       }
  765.       }
  766.     fprintf(trace_file,"GC %d complete: %s\n",collect_count,str);
  767.     fflush(trace_file);
  768.   }
  769. #endif
  770.   return;
  771. }
  772.  
  773. static void free_old_pgs()
  774. {
  775.   PageList tmp;
  776.  
  777.   tmp=S_G_V(free_pages);
  778.   
  779.   if (tmp==NULL)
  780.     S_G_V(free_pages)=S_G_V(old_pages);
  781.   else 
  782.     {
  783.       while(tmp->next!=NULL)
  784.     {
  785.       tmp=tmp->next;
  786.     }
  787.       tmp->next=S_G_V(old_pages);
  788.     }
  789. }
  790.  
  791. void free_weak_ptrs()
  792. {
  793.   LispObject wptr;
  794.   
  795.   wptr=S_G_V(weak_list);
  796.   
  797.   while (wptr!=NULL)
  798.     {
  799.       if (is_forwarded(weak_ptr_val(wptr)))
  800.     weak_ptr_val(wptr)=forwardof(weak_ptr_val(wptr));
  801.       else
  802.     weak_ptr_val(wptr)=nil;
  803.       
  804.       wptr=weak_ptr_chain(wptr);
  805.     }
  806.   S_G_V(weak_list)=NULL;
  807. }
  808. #ifndef NODEBUG
  809. #define CAREFUL_DECLS   \
  810.    LispObject copied; 
  811.  
  812. #ifdef NOLOWTAGINTS
  813. #define copy_obj_careful(x) \
  814.   (copied=copy_object(x),  \
  815.    copied==NULL || ((gcof(copied)&1)==wspace)  \
  816.    ? copied             \
  817.    : (fprintf(stderr,"Wrong space\n"), system_lisp_exit(0), nil))
  818. #else 
  819. #define  copy_obj_careful(x) \
  820.    (copied=copy_object(x),    \
  821.     (copied==NULL || is_fixnum(x) || ((gcof(copied)&1)==wspace))  \
  822.     ? copied \
  823.     : (fprintf(stderr,"Wrong space\n"), system_lisp_exit(0), nil))
  824.  
  825. #endif NOLOWTAGINTS
  826. #else
  827. #define CAREFUL_DECLS 
  828. #define copy_obj_careful(x) (copy_object(x))
  829. #endif
  830.  
  831. #define FORWARD_HEADER(new,obj) \
  832.   lval_typeof(new)=lval_typeof(obj);    \
  833.   gcof(new)=wspace;            \
  834.   class=lval_classof(obj);        \
  835.   set_forwarded(obj,new);
  836.  
  837. #define COPY_ALLOC_SPACE(ptr,size)        \
  838.   ALLOC_SPACE(new,LispObject,ptr,ROUND_ADDR(size)); 
  839.  
  840. /* Hack the stackpointer for GRAB_PAGE */
  841.  
  842. LispObject copy_object(LispObject obj)
  843. {
  844.   int i;
  845.   LispObject new;
  846.   LispObject class;
  847.   CAREFUL_DECLS;
  848.  
  849.   if (obj==NULL) return NULL;
  850. #ifndef NOLOWTAGINTS
  851.   if (is_fixnum(obj)) return obj;
  852. #endif
  853.  
  854.   if (is_forwarded(obj))
  855.     return forwardof(obj);
  856.  
  857.   if (is_newspace(obj))
  858.     return obj;
  859.   else
  860.     {
  861. #ifdef TRACE_GC
  862.       counters[lval_typeof(obj)&255]++;
  863. #endif
  864.  
  865.       switch(lval_typeof(obj))
  866.     {
  867.     case TYPE_NULL:
  868. #if 0
  869.     case TYPE_CONS:
  870. #endif
  871.       /* Null is (cons nil  nil) with hacked type */
  872.       COPY_ALLOC_SPACE(free_ptr,  sizeof(struct cons_structure));
  873.       FORWARD_HEADER(new,obj);
  874.       lval_classof(new)=copy_obj_careful(class);
  875.       CAR(new)=copy_obj_careful(CAR(obj));
  876.       CDR(new)=copy_obj_careful(CDR(obj));
  877.       break;
  878. #if 1
  879.     case TYPE_CONS:
  880.       /* allocate space */
  881.       {    
  882.         LispObject walker,newcons;
  883.         int count, max;
  884.         COPY_ALLOC_SPACE(free_ptr,  sizeof(struct cons_structure));
  885.         FORWARD_HEADER(new,obj);
  886.  
  887.         CAR(new)=class;
  888.         walker=CDR(obj);
  889.         max=1;
  890.         /* Note: this loop does not copy anything */
  891.         while (   walker!=NULL
  892. #ifdef NOLOWTAGINTS
  893.            && !is_fixnum(walker)
  894. #endif
  895.            && is_cons(walker)
  896.            && !is_forwarded(walker)
  897.            && !is_newspace(walker))
  898.           {
  899.         ALLOC_SPACE(newcons,LispObject,free_ptr,  sizeof(struct cons_structure));
  900.         FORWARD_HEADER(newcons,walker);
  901.         /* Keep the class safe */
  902.         CAR(newcons)=class;
  903.         walker=CDR(walker);
  904.         max++;
  905.           }
  906.         /* COPY_BUG(fprintf(stderr,"(List: %d elts",max)); */
  907.  
  908.         newcons=new;
  909.         /* This loop does all the copying 
  910.            end is now the stopping point */
  911.         
  912.         count=0;
  913.         walker=obj;
  914.         while (count<max)
  915.           {
  916.         lval_classof(newcons)=copy_obj_careful(CAR(newcons));
  917.         CAR(newcons)=copy_obj_careful(CAR(walker));
  918.         /* except for the end case equiv to CDR(newcons)=newcons+a bit */
  919.         CDR(newcons)=copy_obj_careful(CDR(walker));
  920.         walker=CDR(walker);
  921.         newcons=CDR(newcons);
  922.         count++;
  923.           }    
  924.       }
  925.       break;
  926. #endif
  927. #ifdef NOLOWTAGINTS      
  928.     case TYPE_INT:
  929.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct integer_structure));
  930.       FORWARD_HEADER(new,obj);
  931.       lval_classof(new)=copy_obj_careful(class);
  932.       intval(new)=intval(obj);
  933.       break;
  934. #endif
  935.     case TYPE_ENV:
  936.        COPY_ALLOC_SPACE(free_ptr,sizeof(struct envobject));
  937.       FORWARD_HEADER(new,obj);
  938.       lval_classof(new)=copy_obj_careful(class);
  939.       new->ENV.variable = copy_obj_careful(obj->ENV.variable);
  940.       new->ENV.value = copy_obj_careful(obj->ENV.value);
  941.       new->ENV.next = (Env) copy_obj_careful((LispObject)obj->ENV.next);
  942.       new->ENV.mutable = copy_obj_careful(obj->ENV.mutable);
  943.       break;
  944.  
  945.     case TYPE_B_MACRO:
  946.     case TYPE_METHOD:
  947.     case TYPE_GENERIC:
  948.     case TYPE_B_FUNCTION:
  949.     case TYPE_INSTANCE:
  950.       /* allocate space */
  951.       i=lval_classof(obj)->CLASS.local_count;
  952.       COPY_ALLOC_SPACE(free_ptr, sizeof(Object_t)+ i*sizeof(LispObject));
  953.       FORWARD_HEADER(new,obj);
  954.       
  955.       lval_classof(new)=copy_obj_careful(class);
  956.       for (i=0 ; i<class->CLASS.local_count ; i++)
  957.         slotref(new,i) = copy_obj_careful(slotref(obj,i));
  958.       break;
  959.       
  960.     case TYPE_VECTOR:
  961.     case TYPE_VECTOR|STATIC_TYPE:
  962.       if (is_static(obj))
  963.         {
  964.          gcof(obj)=wspace; new=obj;
  965.          class=lval_classof(obj);
  966.         }
  967.       else
  968.         {
  969.           COPY_ALLOC_SPACE(free_ptr,sizeof(Object_t)+sizeof(int)+sizeof(LispObject)*obj->VECTOR.length);
  970.           FORWARD_HEADER(new,obj);
  971.         }
  972.       lval_classof(new)= copy_obj_careful(class);
  973.       new->VECTOR.length=obj->VECTOR.length;
  974.       for (i=0; i<obj->VECTOR.length; i++)
  975.         vref(new,i) = copy_obj_careful(vref(obj,i));
  976.       break;
  977.  
  978.     case TYPE_STRING:
  979.       COPY_ALLOC_SPACE(free_ptr,ROUND_ADDR(sizeof(Object_t)+obj->STRING.length+sizeof(int)));
  980.       FORWARD_HEADER(new,obj);
  981.       lval_classof(new)=copy_obj_careful(class);
  982.       new->STRING.length=obj->STRING.length;
  983.       memcpy(stringof(new),stringof(obj),obj->STRING.length);
  984.       break;
  985.  
  986.     case TYPE_CLASS:
  987.       i=lval_classof(obj)->CLASS.local_count;
  988.       COPY_ALLOC_SPACE(free_ptr, sizeof(Object_t)+ i*sizeof(LispObject));
  989.       FORWARD_HEADER(new,obj);
  990.       lval_classof(new)=copy_obj_careful(class);
  991.       (new->CLASS).name = copy_obj_careful(obj->CLASS.name);
  992.       (new->CLASS).superclasses = copy_obj_careful(obj->CLASS.superclasses);
  993.       (new->CLASS).subclasses = copy_obj_careful(obj->CLASS.subclasses);
  994.       (new->CLASS).slot_table = copy_obj_careful(obj->CLASS.slot_table);
  995.       (new->CLASS).slot_list = copy_obj_careful(obj->CLASS.slot_list);
  996.       (new->CLASS).direct_slot_list = copy_obj_careful(obj->CLASS.direct_slot_list);
  997.       (new->CLASS).precedence = copy_obj_careful(obj->CLASS.precedence);
  998.       (new->CLASS).local_count = obj->CLASS.local_count;
  999.       for (i=N_SLOTS_IN_CLASS ; i<class->CLASS.local_count ; i++)
  1000.         slotref(new,i) = copy_obj_careful(slotref(obj,i));
  1001.       break;
  1002.  
  1003.     case TYPE_CHAR:
  1004.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct character_structure));
  1005.       FORWARD_HEADER(new,obj);
  1006.       lval_classof(new)=copy_obj_careful(class);
  1007.       new->CHAR.font=obj->CHAR.font;
  1008.       new->CHAR.code=obj->CHAR.code;
  1009.       break; 
  1010.  
  1011.     case TYPE_TABLE:
  1012.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct table_structure));
  1013.       FORWARD_HEADER(new,obj);
  1014.       lval_classof(new)=copy_obj_careful(class);
  1015.       new->TABLE.comparator=obj->TABLE.comparator;
  1016.       new->TABLE.lisp_comparator= copy_obj_careful(obj->TABLE.lisp_comparator);
  1017.       new->TABLE.tree= copy_obj_careful(obj->TABLE.tree);
  1018.       break;
  1019.  
  1020.     case TYPE_CONTINUE:
  1021.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct continue_structure));
  1022.       FORWARD_HEADER(new,obj);
  1023.       lval_classof(new)=copy_obj_careful(class);
  1024.       (new->CONTINUE).thread = copy_obj_careful(obj->CONTINUE.thread);
  1025.       
  1026.       (new->CONTINUE).value = copy_obj_careful(obj->CONTINUE.value);
  1027.       (new->CONTINUE).target = copy_obj_careful((obj->CONTINUE).target);
  1028.  
  1029.       bcopy((char*)(obj->CONTINUE).machine_state, 
  1030.         (char *)new->CONTINUE.machine_state,
  1031.         sizeof(new->CONTINUE.machine_state));
  1032.       (new->CONTINUE).gc_stack_pointer = obj->CONTINUE.gc_stack_pointer;
  1033.  
  1034.       (new->CONTINUE).dynamic_env = (Env)copy_obj_careful((LispObject)obj->CONTINUE.dynamic_env);
  1035.       (new->CONTINUE).last_continue = copy_obj_careful(obj->CONTINUE.last_continue);
  1036.       (new->CONTINUE).handler_stack = copy_obj_careful(obj->CONTINUE.handler_stack);
  1037.       (new->CONTINUE).dp = copy_obj_careful(obj->CONTINUE.dp);
  1038.  
  1039.       (new->CONTINUE).live = obj->CONTINUE.live;
  1040.       (new->CONTINUE).unwind = obj->CONTINUE.unwind;  
  1041.       break;
  1042.       
  1043.     case TYPE_SPECIAL:
  1044.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct special_structure));
  1045.       FORWARD_HEADER(new,obj);
  1046.       lval_classof(new)=copy_obj_careful(class);
  1047.       new->SPECIAL.name = copy_obj_careful(obj->SPECIAL.name);
  1048.       new->SPECIAL.env = (Env)copy_obj_careful((LispObject)obj->SPECIAL.env);
  1049.       new->SPECIAL.func = obj->SPECIAL.func;
  1050.       break;
  1051.  
  1052.     case TYPE_SYMBOL:    
  1053.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct symbol_structure));
  1054.       FORWARD_HEADER(new,obj);
  1055.       lval_classof(new)=copy_obj_careful(class);
  1056.       (new->SYMBOL).pname = copy_obj_careful(obj->SYMBOL.pname);
  1057.       (new->SYMBOL).lvalue = copy_obj_careful(obj->SYMBOL.lvalue);
  1058.       (new->SYMBOL).lmodule = copy_obj_careful(obj->SYMBOL.lmodule);
  1059.       (new->SYMBOL).gvalue = copy_obj_careful(obj->SYMBOL.gvalue);
  1060.       (new->SYMBOL).plist = copy_obj_careful(obj->SYMBOL.plist);
  1061.       (new->SYMBOL).left = copy_obj_careful(obj->SYMBOL.left);
  1062.       (new->SYMBOL).right = copy_obj_careful(obj->SYMBOL.right);
  1063.       (new->SYMBOL).lhash = copy_obj_careful(obj->SYMBOL.lhash);
  1064.       (new->SYMBOL).hash = (obj->SYMBOL.hash);
  1065.       break;
  1066.  
  1067.     case TYPE_STREAM:
  1068.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct stream_structure));
  1069.       FORWARD_HEADER(new,obj);
  1070.       lval_classof(new) = copy_obj_careful(class);
  1071.       (new->STREAM).handle = obj->STREAM.handle;
  1072.       (new->STREAM).name = copy_obj_careful(obj->STREAM.name);
  1073.       (new->STREAM).mode = obj->STREAM.mode;
  1074.       (new->STREAM).curchar = new->STREAM.curchar;
  1075.       break;
  1076.       
  1077.     case TYPE_C_MODULE: /* These are statically allocated, so just mark */
  1078.       /* forward to here -- unset fwd bit+ set right space */
  1079.       gcof(obj)=wspace; new=obj;
  1080.       class=lval_classof(obj);
  1081.       lval_classof(obj)=copy_obj_careful(class);
  1082.       obj->C_MODULE.name=copy_obj_careful(obj->C_MODULE.name);
  1083.       obj->C_MODULE.home=copy_obj_careful(obj->C_MODULE.home);
  1084.       obj->C_MODULE.imported_modules=copy_obj_careful(obj->C_MODULE.imported_modules);
  1085.       obj->C_MODULE.exported_names=copy_obj_careful(obj->C_MODULE.exported_names);
  1086.       obj->C_MODULE.bindings=copy_obj_careful(obj->C_MODULE.bindings);
  1087.       obj->C_MODULE.entry_count=copy_obj_careful(obj->C_MODULE.entry_count);
  1088.       obj->C_MODULE.values=copy_obj_careful(obj->C_MODULE.values);
  1089.  
  1090.       break;
  1091.  
  1092.     case TYPE_I_MODULE:
  1093.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct i_module_structure));
  1094.       FORWARD_HEADER(new,obj);
  1095.       lval_classof(new)= copy_obj_careful(class);
  1096.       new->I_MODULE.name= copy_obj_careful(obj->I_MODULE.name);
  1097.       new->I_MODULE.home= copy_obj_careful(obj->I_MODULE.home);
  1098.       new->I_MODULE.imported_modules= copy_obj_careful(obj->I_MODULE.imported_modules);
  1099.       new->I_MODULE.exported_names= copy_obj_careful(obj->I_MODULE.exported_names);
  1100.       new->I_MODULE.bindings= copy_obj_careful(obj->I_MODULE.bindings);
  1101.       new->I_MODULE.bounce_flag= obj->I_MODULE.bounce_flag;
  1102.       break;
  1103.  
  1104.     case TYPE_C_FUNCTION:
  1105.     case TYPE_C_MACRO:
  1106.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct c_function_structure));
  1107.       FORWARD_HEADER(new,obj);
  1108.       lval_classof(new) = copy_obj_careful(class);
  1109.       new->C_FUNCTION.name = copy_obj_careful(obj->C_FUNCTION.name);
  1110.       new->C_FUNCTION.home = copy_obj_careful(obj->C_FUNCTION.home);
  1111.       new->C_FUNCTION.env = (Env)copy_obj_careful((LispObject)obj->C_FUNCTION.env);
  1112.       new->C_FUNCTION.argtype = obj->C_FUNCTION.argtype;
  1113.       new->C_FUNCTION.func=obj->C_FUNCTION.func;
  1114.       break;
  1115.       
  1116.     case TYPE_I_FUNCTION:    
  1117.     case TYPE_I_MACRO:
  1118.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct i_function_structure));
  1119.       FORWARD_HEADER(new,obj);
  1120.       lval_classof(new)=copy_obj_careful(class);
  1121.       new->I_FUNCTION.name=copy_obj_careful(obj->I_FUNCTION.name);
  1122.       new->I_FUNCTION.home=copy_obj_careful(obj->I_FUNCTION.home);
  1123.       new->I_FUNCTION.env=(Env)copy_obj_careful((LispObject)obj->I_FUNCTION.env);
  1124.       new->I_FUNCTION.bvl=copy_obj_careful(obj->I_FUNCTION.bvl);
  1125.       new->I_FUNCTION.body=copy_obj_careful(obj->I_FUNCTION.body);
  1126.       new->I_FUNCTION.argtype=obj->I_FUNCTION.argtype;
  1127.       break;
  1128.  
  1129.     case TYPE_FLOAT:
  1130.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct float_structure));
  1131.       FORWARD_HEADER(new,obj);
  1132.       lval_classof(new)=copy_obj_careful(class);
  1133.       new->FLOAT.fvalue=obj->FLOAT.fvalue;
  1134.       break;
  1135. #if (defined(WITH_BSD_SOCKETS) || defined(WITH_SYSTEMV_SOCKETS))
  1136.     case TYPE_LISTENER:
  1137.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct listener_structure));
  1138.       FORWARD_HEADER(new,obj);
  1139.       lval_classof(new)=copy_obj_careful(class);
  1140.       bcopy(&(obj->LISTENER.socket),&(new->LISTENER.socket),sizeof(new->LISTENER.socket));
  1141.       bcopy(&(obj->LISTENER.name),&(new->LISTENER.name),sizeof(new->LISTENER.name));
  1142.       bcopy(&(obj->LISTENER.state),&(new->LISTENER.state),sizeof(new->LISTENER.state));
  1143.       break;
  1144.  
  1145.     case TYPE_SOCKET:
  1146.       COPY_ALLOC_SPACE(free_ptr,sizeof(struct socket_structure));
  1147.       FORWARD_HEADER(new,obj);
  1148.       lval_classof(new)=copy_obj_careful(class);
  1149.       bcopy(&(obj->SOCKET.socket),&(new->SOCKET.socket),sizeof(new->SOCKET.socket));
  1150.       bcopy(&(obj->SOCKET.name),&(new->SOCKET.name),sizeof(new->SOCKET.name));
  1151.       bcopy(&(obj->SOCKET.state),&(new->SOCKET.state),sizeof(new->SOCKET.state));
  1152.       bcopy((obj->SOCKET.buffer),(new->SOCKET.buffer),sizeof(new->SOCKET.buffer));
  1153.       break;
  1154. #endif
  1155.     case TYPE_THREAD:
  1156.       i=lval_classof(obj)->CLASS.local_count;
  1157.       COPY_ALLOC_SPACE(free_ptr, sizeof(Object_t)+ i*sizeof(LispObject));
  1158.       FORWARD_HEADER(new,obj);
  1159.       lval_classof(new) = copy_obj_careful(class);
  1160.       new->THREAD.stack_size = obj->THREAD.stack_size;
  1161.       new->THREAD.gc_stack_size = obj->THREAD.gc_stack_size; 
  1162.  
  1163.       new->THREAD.fun = copy_obj_careful(obj->THREAD.fun);
  1164.       new->THREAD.args = copy_obj_careful(obj->THREAD.args);
  1165.       new->THREAD.value = copy_obj_careful(obj->THREAD.value);
  1166.  
  1167.       new->THREAD.status = obj->THREAD.status;
  1168.  
  1169.       new->THREAD.parent = copy_obj_careful(obj->THREAD.parent);
  1170.       new->THREAD.cochain = copy_obj_careful(obj->THREAD.cochain);
  1171.   
  1172.       new->THREAD.state = copy_obj_careful(obj->THREAD.state);
  1173.     
  1174.       new->THREAD.stack_base = obj->THREAD.stack_base;
  1175.       new->THREAD.gc_stack_base = obj->THREAD.gc_stack_base;
  1176.       for (i=N_SLOTS_IN_THREAD ; i<class->CLASS.local_count ; i++)
  1177.         slotref(new,i) = copy_obj_careful(slotref(obj,i));
  1178.       /* hack */
  1179.       if (obj->THREAD.gc_stack_base+obj->THREAD.gc_stack_size < obj->THREAD.state->CONTINUE.gc_stack_pointer)
  1180.         fprintf(stderr,"GC Stack overflow detected\n");
  1181.  
  1182.       {         
  1183.         LispObject *x=obj->THREAD.gc_stack_base;
  1184.         
  1185.         while (x<obj->THREAD.state->CONTINUE.gc_stack_pointer)
  1186.           { 
  1187.         if (!(((int) *x)&1)) /* Check for tags here */
  1188.           *x = copy_obj_careful(*x);
  1189.         ++x;
  1190.           }
  1191.       }
  1192.       break;
  1193.       
  1194.     case TYPE_WEAK_WRAPPER:
  1195.       COPY_ALLOC_SPACE(free_ptr,WEAK_PTR_SIZE*sizeof(LispObject)+sizeof(Object_t));
  1196.       FORWARD_HEADER(new,obj);    
  1197.       lval_classof(new) = copy_obj_careful(class);  
  1198.       weak_ptr_chain(new)=S_G_V(weak_list);
  1199.       weak_ptr_val(new)=weak_ptr_val(obj);
  1200.       S_G_V(weak_list)=new;
  1201.       break;
  1202.  
  1203.     default:
  1204.       fprintf(stderr,"Can't copy: %x\n",typeof(obj));
  1205.       return obj;
  1206.       break;
  1207.     }
  1208.       return new;
  1209.     }
  1210. }
  1211.  
  1212. /*****************************************/
  1213. /* Old code */
  1214.  
  1215. #ifdef NOWAY     /* Attempt to allocate n objects --- not really viable
  1216. static char * allocate_bytes(LispObject *stacktop,int n);
  1217. LispObject allocate_nbytes(LispObject *stacktop, int size, int type)
  1218. {
  1219.   LispObject object;
  1220.  
  1221.   object=(LispObject) allocate_bytes(stacktop,size);
  1222.  
  1223.   lval_typeof(object)=type;
  1224.   gcof(object)=(short)wspace;
  1225.   return(object);
  1226. }
  1227.  
  1228. LispObject allocate_cbytes(LispObject *stacktop, int n, int size, int type)
  1229. {
  1230.   char *space,*ptr;
  1231.   int i;
  1232.  
  1233.   /* Hope to get lucky of alignment */
  1234.   space= allocate_bytes(stacktop,size*n);
  1235.   ptr=space;
  1236.  
  1237.   for (i=0; i<n; i++)
  1238.     {
  1239.       LispObject new;
  1240.       new=(LispObject)ptr;
  1241.       lval_typeof(new)=type;
  1242.       gcof(new)=wspace;
  1243.       
  1244.       ptr+=size;
  1245.     }
  1246.   return (LispObject) space;
  1247. }    
  1248. #endif
  1249.  
  1250.